home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Reference Notes / Utilities.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  12.1 KB  |  344 lines  |  [TEXT/gamI]
  1. ; ----------------------------------------------------------------------------
  2. ; File:        Utilities.scm
  3. ; Description: Assorted utility functions.
  4. ; Author:      Raymond Laning at ART
  5. ; Created:     28-Apr-93
  6. ; Modified:    07-Dec-93  23:18:51 Raymond Laning
  7. ; Language:    Scheme
  8. ; Status:      Experimental (Do Not Distribute)
  9. ;
  10. ;          (c) Copyright 1993, Advanced Robotic Technologies, Inc.
  11. ;              All Rights Reserved.
  12. ;
  13. ; ----------------------------------------------------------------------------
  14.  
  15. (define $pi 3.141592653589793)
  16.  
  17. (define $close-enough .00001)
  18.  
  19. (define (close-enough? arg1 arg2)
  20.   (< (- arg1 arg2) $close-enough))
  21.  
  22. (define (atom? x1)
  23.   (not (list? x1))
  24. )
  25.  
  26. (define (precision num places)
  27.   (let* (
  28.          (mnum (* num (expt 10 places)))
  29.          (rnum (round mnum))
  30.          )
  31.     (/ rnum (expt 10 places)))
  32. )
  33.  
  34. (define (sqrd arg) (* arg arg))
  35.  
  36. (define (factorial number)
  37.   (if (> number 1)
  38.     (do ((i (- number 1) (- i 1))
  39.          (result number (* result i)))
  40.         ((<= i 1) result))
  41.     1))
  42.  
  43. (define (binomial-coeff n i)
  44.   (/ (factorial n) (factorial i) (factorial (- n i))))
  45.  
  46. (define (distance-sqrd v1 v2)
  47.   (apply + (map (lambda (x1 x2) (let ((diff (- x1 x2))) (* diff diff))) v1 v2)))
  48.  
  49. ;;;integer-coerce takes a number and returns the rounded integer
  50. ;;;(would not be necessary if round returned a TRUE integer in MacGambit)
  51. (define (integer-coerce num)
  52.   (inexact->exact (round num)))
  53.  
  54. (define (make-counter)
  55.   (let ((count 0))
  56.     (lambda () (set! count (+ 1 count)) count)))
  57.  
  58. (define counter (make-counter))
  59.  
  60. (define (degrees-to-radians angle)
  61.   (/ (* $pi angle) 180))
  62.  
  63. (define (radians-to-degrees angle)
  64.   (* 180.0 (/ angle $pi)))
  65.  
  66. (define (format port format-string . restargs)
  67.   (let ((len (string-length format-string)))
  68.     (if (and (not (number? port)) (not (output-port? port)))
  69.       (set! port ##stdout))
  70.     (do ((i 0))
  71.         ((>= i len))
  72.       (case (string-ref format-string i)
  73.         ((#\~)
  74.          (case (string-ref format-string (+ i 1))
  75.            ((#\a #\A)
  76.             (display (car restargs) port)
  77.             (set! restargs (cdr restargs))
  78.             (set! i (+ i 2)))
  79.            ((#\s #\S)
  80.             (write (car restargs) port)
  81.             (set! restargs (cdr restargs))
  82.             (set! i (+ i 2)))
  83.            ((#\d #\D)
  84.             (##write-string (##number->string (car restargs) 10) port)
  85.             (set! restargs (cdr restargs))
  86.             (set! i (+ i 2)))
  87.            ((#\%)
  88.             (newline port)
  89.             (set! i (+ i 2)))
  90.            ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  91.             (print-number-delimited
  92.              (number->string (car restargs))
  93.              (- (char->integer (string-ref format-string (+ i 1))) 48)
  94.              port)
  95.             (set! restargs (cdr restargs))
  96.             (set! i (+ i 2)))
  97.            (else (write "Bad format character ")
  98.                  (write-char (string-ref format-string i))
  99.                  (write " at position")
  100.                  (write i)
  101.                  (newline))))
  102.         (else
  103.          (write-char (string-ref format-string i) port)
  104.          (set! i (+ i 1))))))
  105.   #f)
  106.  
  107. (define (string-member? char string)
  108.   (do ((i 0 (+ i 1))
  109.        (done #f))
  110.       ((or done (>= i (string-length string))) (if done (- i 1) done))
  111.     (if (char-ci=? (string-ref string i) char)
  112.       (set! done #t))))
  113.  
  114. (define (string-right-trim string trimchar)
  115.   (let ((len (- (string-length string) 1)))
  116.     (do ((i len (- i 1))
  117.          (done #f))
  118.         ((or done (< i 0))
  119.          (if done (substring string (+ i 2) (+ 1 len)) string))
  120.       (if (char=? trimchar (string-ref string i))
  121.         (set! done #t)))))
  122.  
  123. (define (string-downcase string)
  124.   (let ((len (string-length string)))
  125.     (do ((i 0 (+ i 1))
  126.          (newstring (string-copy string)))
  127.          ((>= i len) newstring)
  128.       (string-set! newstring i (char-downcase (string-ref string i))))))
  129.  
  130. (define (print-number-delimited number-string stlength port)
  131.   (let ((strlen (string-length number-string))
  132.         (exponential? (string-member? #\e number-string)))
  133.     (cond ((and (> stlength strlen) (string-member? #\. number-string))
  134.            (set! number-string (string-append
  135.                                 number-string
  136.                                 (make-string (- stlength strlen) #\0))))
  137.           ((> stlength strlen)
  138.            (set! number-string (string-append
  139.                                 number-string
  140.                                 "."
  141.                                 (make-string (- stlength strlen 1) #\0)))))
  142.     (if exponential?
  143.       (##write-string (string-append
  144.                 (substring number-string 0 (- stlength (- strlen exponential?)))
  145.                 (substring number-string exponential? strlen))
  146.                port)
  147.       (##write-string (substring number-string 0 stlength) port))))
  148.  
  149. (define (do-load-file foo)
  150.   (let ((filename (mac#sfgetfile "Select file to load" "TEXTgamO")))
  151.     (if filename
  152.       (begin
  153.         (##display "Loading " ##stdout #f)
  154.         (##write filename ##stdout #f)
  155.         (##newline ##stdout)
  156.         (##load filename #f)))))
  157.  
  158. (define (do-compile-file foo)
  159.   (let ((filename (mac#sfgetfile "Select file to compile" "TEXT")))
  160.     (if filename
  161.       (begin
  162.         (##display "Compiling " ##stdout #f)
  163.         (##write filename ##stdout #f)
  164.         (##newline ##stdout)
  165.         (if (##procedure? c#cf)
  166.           (c#cf filename 'm68000)
  167.           (dylan-call dylan:load filename))))))
  168.  
  169. (define current-ids
  170.   (list (list (mac#getmenu 134) "Special"
  171.                                 (list (list #f "Load..." do-load-file)
  172.                                       (list #f "Compile..." do-compile-file)))))
  173.  
  174. (define current-subids #f)
  175.  
  176. (define current-menu-id 145)
  177.  
  178. (define (add-to-menu-list menuhandle name toplevel?)
  179.   (cond (toplevel?
  180.          (mac#insertmenu menuhandle 0)
  181.          (set! current-ids (append current-ids (list (list menuhandle name))))
  182.          (mac#drawmenubar)
  183.          (- (length current-ids) 1))
  184.         (#t
  185.          (mac#insertmenu menuhandle -1)
  186.          (set! current-subids
  187.                (append current-subids (list (list menuhandle name))))
  188.          (mac#drawmenubar)
  189.          (- (length current-subids) 1)
  190.          )))
  191.  
  192. (define (add-new-menu name)
  193.   (let* ((mh (mac#newmenu current-menu-id name)))
  194.     (set! current-menu-id (+ current-menu-id 1))
  195.     (add-to-menu-list mh name #t)))
  196.  
  197. (define (add-old-menu name menuid)
  198.   (let ((menuhandle (mac#getmenu menuid)))
  199.     (mac#insertmenu menuhandle 0)
  200.     (set! current-ids (append current-ids (list (list menuhandle name))))))
  201.  
  202. (define (do-men-selection selection)
  203.   (let* ((menu (mac#getmhandle (##fixnum.ash selection -16)))
  204.          (item (##fixnum.logand selection 65535))
  205.          (menurecord (assoc menu current-ids)))
  206.     (if menurecord
  207.       (if (<= item (length (caddr menurecord)))
  208.         (apply (caddr (list-ref (caddr menurecord) (- item 1))) (list item))
  209.         (format #t "Bogus choice number ~s~%" item))
  210.       (let ((newmenurec (assoc menu current-subids)))
  211.         (if newmenurec
  212.           (apply (caddr (list-ref (caddr newmenurec) (- item 1))) (list item))
  213.           (format #t "Bogus menu # ~s~%" menu))))
  214.     (mac#hilitemenu 0))
  215.   ##unprint-object)
  216.  
  217. (define $menu-separator "Separator")
  218.  
  219. (define (add-menu-item whichmenu itemtitle action hot-key has-subs? sep?)
  220.   (if (< whichmenu (length current-ids))
  221.     (let* ((menurecord (list-ref current-ids whichmenu))
  222.            (submenurecord (cddr menurecord))
  223.            (menuhan (car menurecord))
  224.            (newmh #f))
  225.       (cond (has-subs?
  226.              (let* ((submenu-thing "!ê/ ")
  227.                     (no-thing (string-set! submenu-thing 3 (integer->char 27)))
  228.                     (no-thing2
  229.                      (string-set!
  230.                       submenu-thing 1 (integer->char current-menu-id)))
  231.                     (newtitle (string-append itemtitle submenu-thing)))
  232.                (set! newmh (mac#newmenu current-menu-id itemtitle))
  233.                (set! current-menu-id (+ current-menu-id 1))
  234.                (mac#appendmenu menuhan newtitle)
  235.                (add-to-menu-list newmh itemtitle #f)
  236.                ))
  237.             (hot-key
  238.              (let* ((sub-thing "/"))
  239.                (if sep?
  240.                  (set! sub-thing
  241.                        (string-append "-;" itemtitle sub-thing hot-key))
  242.                  (set! sub-thing (string-append itemtitle sub-thing hot-key)))
  243.                (mac#appendmenu menuhan sub-thing)))
  244.             (sep? (mac#appendmenu menuhan (string-append "-;" itemtitle)))
  245.             (#t (mac#appendmenu menuhan itemtitle)))
  246.       (cond ((and (null? submenurecord) sep?) ;first subitem, w/seperator
  247.              (set-cdr! (cdr menurecord)
  248.                        (list (list $menu-separator
  249.                                    (list newmh itemtitle action))))
  250.              1)
  251.             ((null? submenurecord) ;first subitem
  252.              (set-cdr! (cdr menurecord)
  253.                        (list (list (list newmh itemtitle action))))
  254.              0)
  255.             (sep? (set-cdr! (list-tail (car submenurecord)
  256.                                        (- (length (car submenurecord)) 1))
  257.                             (list $menu-separator
  258.                                   (list newmh itemtitle action)))
  259.                   (- (length (car submenurecord)) 1))
  260.             (#t (set-cdr! (list-tail (car submenurecord)
  261.                                      (- (length (car submenurecord)) 1))
  262.                           (list (list newmh itemtitle action)))
  263.                 (- (length (car submenurecord)) 1))))
  264.     (error "Not a valid menu id to add item to:" whichmenu itemtitle)))
  265.  
  266. (define (add-menu-separator whichmenu)
  267.   (let* ((menurecord (list-ref current-ids whichmenu))
  268.          (menuhan (car menurecord)))
  269.     (mac#appendmenu menuhan ";")))
  270.  
  271. (define (add-submenu-item menuid itemid subitemtitle action)
  272.   (let* ((menurec (list-ref current-ids menuid))
  273.          (itemrec (list-ref (caddr menurec) itemid))
  274.          (menuhan (car itemrec))
  275.          (subitem (assoc menuhan current-subids))
  276.          (subitemlist (cddr subitem)))
  277.     (if (null? subitemlist)
  278.       (set-cdr! (cdr subitem) (list (list (list #f subitemtitle action))))
  279.       (set-cdr! (list-tail (car subitemlist) (- (length (car subitemlist)) 1))
  280.                 (list (list #f subitemtitle action))))
  281.     (mac#appendmenu menuhan subitemtitle)))
  282.  
  283. (define (disable-menitem menunum item)
  284.   (let* ((menurec (list-ref current-ids menunum))
  285.          (menuhan (car menurec)))
  286.     (mac#disableitem menuhan item)))
  287.  
  288. (define (disable-submenitem menunum submenunum item)
  289.   (let* ((menurec (list-ref current-ids menunum))
  290.          (itemrec (list-ref (caddr menurec) submenunum))
  291.          (menuhan (car itemrec)))
  292.     (mac#disableitem menuhan item)))
  293.  
  294.  
  295. (define (enable-menitem menunum item)
  296.   (let* ((menurec (list-ref current-ids menunum))
  297.          (menuhan (car menurec)))
  298.     (mac#enableitem menuhan item)))
  299.  
  300. (define (check-menitem menunum item flag)
  301.   (let* ((menurec (list-ref current-ids menunum))
  302.          (menuhan (car menurec)))
  303.     (mac#checkitem menuhan item flag)))
  304.  
  305. (define (check-submenitem menunum submenunum item flag)
  306.   (let* ((menurec (list-ref current-ids menunum))
  307.          (itemrec (list-ref (caddr menurec) submenunum))
  308.          (menuhan (car itemrec)))
  309.     (mac#checkitem menuhan item flag)))
  310.  
  311. (define (butlast . args)
  312.   (let* ((thelist (car args))
  313.          (endnum (if (null? (cdr args))
  314.                    (- (length thelist) 2)
  315.                    (- (length thelist) (cadr args) 1))))
  316.     (do ((i endnum (- i 1))
  317.          (outlist (list)))
  318.         ((negative? i) outlist)
  319.       (set! outlist (cons (list-ref thelist i) outlist)))))
  320.  
  321. (define (last thelist)
  322.   (car (list-tail thelist (- (length thelist) 1))))
  323.  
  324. (define (remove member list)
  325.   (do ((restlist list (cdr restlist))
  326.        (i 0 (+ i 1))
  327.        (done? #f))
  328.       ((or done? (null? restlist)) list)
  329.     (cond ((and (zero? i) (equal? member (car restlist)))
  330.            (set! done? #t)
  331.            (set! list (cdr list)))
  332.           ((equal? member (car restlist))
  333.            (set! done? #t)
  334.            (set-cdr! (list-tail list (- i 1)) (cdr restlist))))))
  335.  
  336. (##define-macro (decrement foo)
  337.    `(let ((num ,(- (eval foo) 1))) (set! ,foo num) num))
  338.  
  339. (##define-macro (increment foo)
  340.    `(let ((num ,(+ (eval foo) 1))) (set! ,foo num) num))
  341.  
  342. (define (signums tesnum othernum)
  343.   (if (negative? tesnum) (- othernum) othernum))
  344.